perm filename FORMAT.OLD[LSP,SYS] blob
sn#012122 filedate 1973-07-03 generic text, type T, neo UTF8
00100 (DECLARE (SPECIAL LINCNT PAGEHEIGHT PAGEWIDTH)
00200 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
00300 (SPECIAL *LP *RP *SL *AM *RO *AT *LB *RB)
00400 (DEFPROP DATAERR T *FSUBR))
00500
00600 (COMMENT FORMAT PROGRAM MACROS)
00700
00800 (DEFPROP ATLEFT (LAMBDA (L) (LIST (Q EQ) 1 (Q (CURCOL)))) MACRO)
00900
01000 (DEFPROP COLUMN (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
01100
01200 (DEFPROP DFUNC
01300 (LAMBDA (L)
01400 (LIST (Q DEFPROP)
01500 (CAADR L)
01600 (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
01700 (Q EXPR)))
01800 MACRO)
01900
02000 (DEFPROP HEIGHT (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
02100
02200 (DEFPROP MAPDEF
02300 (LAMBDA (L)
02400 (LIST (Q MAPCAR)
02500 (SUBST (CADR L)
02600 (Q IND)
02700 (Q (FUNCTION (LAMBDA (PAIR)
02800 (PUTPROP (CAR PAIR)
02900 (CADR PAIR)
03000 (QUOTE IND))))))
03100 (LIST (Q QUOTE) (CDDR L))))
03200 MACRO)
03300
03400 (DEFPROP MCONS
03500 (LAMBDA (L)
03600 (COND ((NULL (CDDR L)) (CADR L))
03700 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
03800 MACRO)
03900
04000 (DEFPROP NEWBUF (LAMBDA (L) (LIST (Q LIST) 0 1 0)) MACRO)
04100
04200 (DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
04300
04400 (DEFPROP STRING (LAMBDA (L) (CONS (Q CDDDR) (CDR L))) MACRO)
04500
04600 (DEFPROP WIDTH (LAMBDA (L) (CONS (Q CADDR) (CDR L))) MACRO)
04700
04800 (COMMENT END OF FORMAT PROGRAM MACROS)
04900
05000 (COMMENT PROPERTY TABLE PRIMITIVES)
05100
00100 (DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
00200
00300 (DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
00400
00500 (DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
00600
00700 (DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
00800
00900 (DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
01000
01100 (DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
01200
01300 (DFUNC (DELETEPROP IDENT PROPNAM)
01400 (PROG (TEM)
01500 (SETQ TEM IDENT)
01600 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
01700 (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
01800 (RETURN T)))
01900 (SETQ TEM (CDDR TEM))
02000 (GO LOOP)))
02100
02200 (DFUNC (GETGET ATOM PROP)
02300 (PROG (TEM PTAB)
02400 (SETQ PTAB (FIRSTPROP ATOM))
02500 LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
02600 (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
02700 (RETURN TEM)))
02800 (SETQ PTAB (NEXTPROP PTAB))
02900 (GO LOOP)))
03000
03100 (DFUNC (INITPROP IDENT PROPNAM PROPVAL)
03200 (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
03300
03400 (DFUNC (SEEKPROP IDENT PROP) (GETL IDENT (LIST PROP)))
03500
03600 (DFUNC (SETPROP IDENT PROPNAM PROPVAL)
03700 (PUTPROP IDENT PROPVAL PROPNAM))
03800
03900 (COMMENT END OF PROPERTY TABLE PRIMITIVES)
04000
00100 (DFUNC (BUFASSIGN EXPR WIDTH RPARS SLACK)
00200 (PROG (COMS MARG REST)
00300 (SETQ COMS (NEWBUF))
00400 (MKLPR COMS)
00500 (MKEXPR COMS (CAR EXPR))
00600 (MKSPC COMS)
00700 (MKEXPR COMS (CADR EXPR))
00800 (SETQ MARG (ADD1 (COLUMN COMS)))
00900 (SETQ REST (BUFLIST (CDDR EXPR)
01000 (*DIF WIDTH MARG)
01100 (ADD1 RPARS)
01200 (PLUS SLACK (SUB1 MARG))))
01300 (COND ((NOT (*GREAT (FULLWTH REST (ADD1 RPARS))
01400 (*DIF WIDTH MARG)))
01500 (RETURN (MKRPR (MKLIST COMS MARG REST)))))
01600 (SETQ MARG (*DIF MARG (ADD1 (FLATSIZE (CADR EXPR)))))
01700 (SETQ REST (BUFLIST (CDDR EXPR)
01800 (*DIF WIDTH MARG)
01900 (ADD1 RPARS)
02000 (PLUS SLACK (SUB1 MARG))))
02100 (COND ((NOT (*GREAT (FULLWTH REST (ADD1 RPARS))
02200 (*DIF WIDTH MARG)))
02300 (RETURN (MKRPR (MKLIST COMS MARG REST)))))
02400 (RETURN (MKRPR (MKLIST COMS
02500 1
02600 (BUFLIST (CDDR EXPR)
02700 (SUB1 WIDTH)
02800 (ADD1 RPARS)
02900 SLACK))))))
03000
03100 (DFUNC (BUFATOMS ATOMS WIDTH RPARS SLACK)
03200 (PROG (COMS WTH)
03300 (SETQ COMS (NEWBUF))
03400 (COND ((NOT (NULL ATOMS)) (MKEXPR COMS (CAR ATOMS))
03500 (SETQ ATOMS (CDR ATOMS))))
03600 LOOP (COND ((NULL ATOMS) (RETURN COMS)))
03700 (SETQ WTH (PLUS (COLUMN COMS) 1 (FLATSIZE (CAR ATOMS))))
03800 (COND ((NULL (CDR ATOMS)) (SETQ WTH (ADD1 WTH))))
03900 (COND ((GREATERP WTH WIDTH) (MKTAB COMS 0)) (T (MKSPC COMS)))
04000 (MKEXPR COMS (CAR ATOMS))
04100 (SETQ ATOMS (CDR ATOMS))
04200 (GO LOOP)))
04300
00100 (DFUNC (BUFDEFS EXPR WIDTH RPARS SLACK)
00200 (PROG (COMS MARG REST)
00300 (SETQ COMS (NEWBUF))
00400 (MKLPR COMS)
00500 (MKEXPR COMS (CAR EXPR))
00600 (MKSPC COMS)
00700 (MKEXPR COMS (CADR EXPR))
00800 (SETQ MARG (PLUS (FLATSIZE (CAR EXPR)) 2))
00900 (SETQ REST (BUFLIST (CDDR EXPR)
01000 (SUB1 WIDTH)
01100 (ADD1 RPARS)
01200 SLACK))
01300 (COND ((GREATERP (FULLWTH REST (ADD1 RPARS))
01400 (*DIF WIDTH MARG))
01500 (SETQ MARG 1)))
01600 (RETURN (MKRPR (MKLIST COMS MARG REST)))))
01700
01800 (DFUNC (BUFDEDFDM EXPR WIDTH RPARS SLACK)
01900 (PROG (COMS MARG MARG1 REST)
02000 (SETQ COMS (NEWBUF))
02100 (MKLPR COMS)
02200 (MKEXPR COMS (CAR EXPR))
02300 (MKSPC COMS)
02400 (MKEXPR COMS (CADR EXPR))
02500 (MKSPC COMS)
02600 (MKEXPR COMS (CADDR EXPR))
02700 (SETQ MARG1 (PLUS (FLATSIZE (CAR EXPR)) 2))
02800 (SETQ MARG (PLUS MARG1 (FLATSIZE (CADR EXPR)) 1))
02900 (SETQ REST (BUFLIST (CDDDR EXPR)
03000 (SUB1 WIDTH)
03100 (ADD1 RPARS)
03200 SLACK))
03300 (COND ((*GREAT (FULLWTH REST (ADD1 RPARS)) (*DIF WIDTH MARG))
03400 (SETQ MARG MARG1)))
03500 (COND ((*GREAT (FULLWTH REST (ADD1 RPARS)) (*DIF WIDTH MARG))
03600 (SETQ MARG 1)))
03700 (RETURN (MKRPR (MKLIST COMS MARG REST)))))
03800
00100 (DFUNC (BUFEXPR EXPR WIDTH RPARS SLACK)
00200 (PROG (COMS FIRST MARG REST TEM)
00300 (COND ((ATOM EXPR) (RETURN (MKEXPR (NEWBUF) EXPR))))
00400 (COND ((AND (ATOM (CAR EXPR))
00500 (NOT (NUMBERP (CAR EXPR)))
00600 (SETQ TEM (GETGET (CAR EXPR) (Q BUFFPRIN))))
00700 (RETURN ((PROPVAL TEM) EXPR WIDTH RPARS SLACK))))
00800 (SETQ COMS (MKEXPR (NEWBUF) EXPR))
00900 (COND ((NOT (GREATERP (PLUS (COLUMN COMS) RPARS) WIDTH))
01000 (RETURN COMS)))
01100 (SETQ COMS (MKLPR (NEWBUF)))
01200 (COND ((ATOM (CDR EXPR))
01300 (RETURN (MKRPR (MKLIST COMS
01400 1
01500 (BUFLIST EXPR
01600 (SUB1 WIDTH)
01700 (ADD1 RPARS)
01800 SLACK))))))
01900 (SETQ FIRST (BUFEXPR (CAR EXPR) (SUB1 WIDTH) 0 SLACK))
02000 (SETQ MARG (PLUS (COLUMN FIRST) 2))
02100 (COND ((ATOM (CAR EXPR)) (GO ATOM)))
02200 (SETQ REST (BUFLIST (CDR EXPR)
02300 (SUB1 WIDTH)
02400 (ADD1 RPARS)
02500 SLACK))
02600 (COND ((OR (GREATERP (HEIGHT FIRST) 1)
02700 (LESSP (*DIF WIDTH MARG)
02800 (FULLWTH REST (ADD1 RPARS))))
02900 (RETURN (MKRPR (MKLIST COMS 1 (MKAPP FIRST REST))))))
03000 (RETURN (MKRPR (MKLIST (MKEXPR COMS (CAR EXPR)) MARG REST)))
03100 ATOM (SETQ REST (BUFLIST (CDR EXPR)
03200 (*DIF WIDTH MARG)
03300 (ADD1 RPARS)
03400 (PLUS SLACK (SUB1 MARG))))
03500 (COND ((LESSP (PLUS SLACK (*DIF WIDTH MARG))
03600 (FULLWTH REST (ADD1 RPARS)))
03700 (RETURN (MKRPR (MKLIST (MKEXPR COMS (CAR EXPR))
03800 1
03900 (BUFLIST (CDR EXPR)
04000 (SUB1 WIDTH)
04100 (ADD1 RPARS)
04200 SLACK))))))
04300 (RETURN (MKRPR (MKLIST (MKEXPR COMS (CAR EXPR)) MARG REST)))))
04400
00100 (DFUNC (BUFLIST LIST WIDTH RPARS SLACK)
00200 (PROG (COMS)
00300 (SETQ COMS (NEWBUF))
00400 LOOP (MKAPP COMS
00500 (BUFEXPR (CAR LIST)
00600 WIDTH
00700 (COND ((NULL (CDR LIST)) RPARS)
00800 ((ATOM (CDR LIST))
00900 (PLUS RPARS (FLATSIZE (CDR LIST)) 3))
01000 (T 0))
01100 SLACK))
01200 (SETQ LIST (CDR LIST))
01300 (COND ((NULL LIST) (RETURN COMS)))
01400 (COND ((ATOM LIST) (RETURN (MKATOM COMS LIST))))
01500 (GO LOOP)))
01600
01700 (DFUNC (BUFMAPDEF EXPR WIDTH RPARS SLACK)
01800 (PROG (ATMS COMS MARG)
01900 (SETQ COMS (NEWBUF))
02000 (MKLPR COMS)
02100 (MKEXPR COMS (CAR EXPR))
02200 (MKSPC COMS)
02300 (MKEXPR COMS (CADR EXPR))
02400 (MKSPC COMS)
02500 (SETQ MARG (COLUMN COMS))
02600 (SETQ ATMS (BUFATOMS (CDDR EXPR)
02700 (*DIF WIDTH MARG)
02800 (ADD1 RPARS)
02900 SLACK))
03000 (RETURN (MKRPR (MKLIST COMS MARG ATMS)))))
03100
00100 (DFUNC (BUFPROG EXPR WIDTH RPARS SLACK)
00200 (PROG (COMS INDENT PVARS STATS)
00300 (SETQ COMS (NEWBUF))
00400 (MKLPR COMS)
00500 (MKEXPR COMS (CAR EXPR))
00600 (MKSPC COMS)
00700 (SETQ INDENT (PLUS (FLATSIZE (CAR EXPR)) 2))
00800 (SETQ PVARS (BUFPVARS (CADR EXPR)
00900 (*DIF WIDTH INDENT)
01000 (COND ((NULL (CDDR EXPR)) (ADD1 RPARS))
01100 (T 0))
01200 SLACK))
01300 (MKLIST COMS INDENT PVARS)
01400 (SETQ STATS (CDDR EXPR))
01500 LOOP (COND ((NULL STATS) (RETURN (MKRPR COMS))))
01600 (COND ((ATOM (CAR STATS)) (MKEXPR (MKTAB COMS 1) (CAR STATS)))
01700 (T (MKLIST COMS
01800 INDENT
01900 (BUFEXPR (CAR STATS)
02000 (*DIF WIDTH INDENT)
02100 (COND ((NULL (CDR STATS))
02200 (ADD1 RPARS))
02300 (T 0))
02400 SLACK))))
02500 (SETQ STATS (CDR STATS))
02600 (GO LOOP)))
02700
02800 (DFUNC (BUFPVARS VARS WIDTH RPARS SLACK)
02900 (PROG (ATMS COMS)
03000 (SETQ COMS (NEWBUF))
03100 (COND ((OR (ATOM VARS)
03200 (NOT (GREATERP (FLATSIZE VARS)
03300 (*DIF WIDTH RPARS))))
03400 (RETURN (MKEXPR COMS VARS))))
03500 (SETQ ATMS (BUFATOMS VARS (SUB1 WIDTH) (ADD1 RPARS) SLACK))
03600 (RETURN (MKRPR (MKLIST (MKLPR COMS) 1 ATMS)))))
03700
03800 (DFUNC (BUFSPECIAL EXPR WIDTH RPARS SLACK)
03900 (PROG (ATMS COMS INDENT)
04000 (SETQ COMS (NEWBUF))
04100 (SETQ INDENT (PLUS (FLATSIZE (CAR EXPR)) 2))
04200 (MKLPR COMS)
04300 (MKEXPR COMS (CAR EXPR))
04400 (MKSPC COMS)
04500 (SETQ ATMS (BUFATOMS (CDR EXPR)
04600 (*DIF WIDTH INDENT)
04700 (ADD1 RPARS)
04800 SLACK))
04900 (RETURN (MKRPR (MKLIST COMS INDENT ATMS)))))
05000
05100 (DFUNC (CURCOL) (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))
05200
00100 (DEFPROP DATAERR
00200 (LAMBDA (L) (PROG NIL (INC NIL T) (OUTC NIL T) (PRINT L)))
00300 FEXPR)
00400
00500 (DFUNC (DOEXCEPT EXPR WIDTH RPARS SLACK)
00600 ((GET (CAR EXPR) (Q EXCEPTBUFF)) EXPR WIDTH RPARS SLACK))
00700
00800 (DFUNC (DOSPEC EXPR WIDTH RPARS SLACK)
00900 (PROG (COMS)
01000 (SETQ COMS (MKEXPR (NEWBUF) EXPR))
01100 (COND ((NOT (GREATERP (PLUS (COLUMN COMS) RPARS) WIDTH))
01200 (RETURN COMS)))
01300 (RETURN ((GET (CAR EXPR) (Q SPECBUFF)) EXPR
01400 WIDTH
01500 RPARS
01600 SLACK))))
01700
01800 (DFUNC (DOFILE DOREADS INFILE OUTFILE)
01900 (PROG (LINCNT)
02000 (SETQ LINCNT 0)
02100 (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
02200 (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
02300 (INC (Q INCHAN) NIL)
02400 (OUTC (Q OUTCHAN) NIL)
02500 (DOREADS)
02600 (OUTC NIL T)
02700 (INC NIL T)))
02800
02900 (DEFPROP FORMAT
03000 (LAMBDA (L)
03100 (PROG (DEV)
03200 (SETQ DEV (Q DSK:))
03300 LOOP (COND ((NULL L) (RETURN NIL)))
03400 (COND ((%DEVP (CAR L)) (SETQ DEV (CAR L)) (SETQ L (CDR L))))
03500 (FORMFILE (LIST DEV (CAR L))
03600 (LIST (Q DSK:)
03700 (CONS (COND ((ATOM (CAR L)) (CAR L))
03800 (T (CAAR L)))
03900 (Q FMT))))
04000 (SETQ L (CDR L))
04100 (GO LOOP)))
04200 FEXPR)
04300
00100 (DFUNC (FORMFILE INFILE OUTFILE)
00200 (PROG (LINCNT)
00300 (INC (EVAL (MCONS (Q INPUT) (GENSYM) INFILE)))
00400 (OUTC (EVAL (MCONS (Q OUTPUT) (GENSYM) OUTFILE)))
00500 (LINELENGTH PAGEWIDTH)
00600 (SETQ LINCNT 1)
00700 (FORMREADS)
00800 (INC NIL T)
00900 (OUTC NIL T)
01000 (RETURN NIL)))
01100
01200 (DEFPROP FORMFUNS
01300 (LAMBDA (NAMES)
01400 (PROG (DONE PROP NAME FLAG FLAGS LINCNT)
01500 (SETQ LINCNT 1)
01600 (LINEF 1)
01700 LOOP (COND ((NULL NAMES) (RETURN (REVERSE DONE))))
01800 (SETQ FLAGS (QUOTE (EXPR FEXPR VALUE MACRO)))
01900 (SETQ NAME (CAR NAMES))
02000 (SETQ NAMES (CDR NAMES))
02100 ILOOP(COND ((NULL FLAGS) (GO LOOP)))
02200 (SETQ FLAG (CAR FLAGS))
02300 (SETQ FLAGS (CDR FLAGS))
02400 (SETQ PROP (GETL NAME (LIST FLAG)))
02500 (COND ((NULL PROP) (GO ILOOP)))
02600 (SETQ DONE (CONS (CONS NAME FLAG) DONE))
02700 (SETQ PROP (CADR PROP))
02800 (COND ((NOT (ATLEFT)) (LINEF 1)))
02900 (FORMANEXPR (LIST (QUOTE DEFPROP) NAME PROP FLAG))
03000 (LINEF 1)
03100 (GO ILOOP)))
03200 FEXPR)
03300
03400 (DFUNC (FORMF) (PROG NIL (PRINC *FF) (SETQ LINCNT 1)))
03500
03600 (DFUNC (FORMANEXPR ANEXPR)
03700 (PROG (BUF)
03800 (COND ((OR (ATOM ANEXPR) (NOT (EQ (CAR ANEXPR) (Q LAP))))
03900 (SETQ BUF (BUFEXPR ANEXPR (LINELENGTH NIL) 0 0))
04000 (COND ((GREATERP (ADD1 (HEIGHT BUF))
04100 (*DIF PAGEHEIGHT (SUB1 LINCNT)))
04200 (COND ((NOT (EQ LINCNT 1)) (FORMF)))))
04300 (PRINTIT (STRING BUF) 0))
04400 (T (PRINTLAP (READLAP ANEXPR))))
04500 (COND ((NOT (ATLEFT)) (LINEF 2)))
04600 (RETURN NIL)))
04700
04800 (DFUNC (FORMREADS) (READLOOP (FUNCTION FORMANEXPR)))
04900
05000 (DFUNC (FULLWTH BUF RPARS)
05100 (MAX (WIDTH BUF) (PLUS (COLUMN BUF) RPARS)))
05200
00100 (DFUNC (LINEF NUM)
00200 (PROG NIL
00300 (COND ((LESSP NUM 0) (RETURN NIL)))
00400 (SETQ LINCNT (PLUS LINCNT NUM))
00500 LOOP (COND ((ZEROP NUM) (RETURN NIL)))
00600 (TERPRI)
00700 (SETQ NUM (SUB1 NUM))
00800 (GO LOOP)))
00900
01000 (DFUNC (MAX N M) (COND ((GREATERP N M) N) (T M)))
01100
01200 (DFUNC (MKAPP BUF1 BUF2)
01300 (SETCOL (SETHT (SETWTH (SETSTRING BUF1
01400 (NCONC (STRING (MKTAB BUF1 0))
01500 (STRING BUF2)))
01600 (MAX (WIDTH BUF1) (WIDTH BUF2)))
01700 (SUB1 (PLUS (HEIGHT BUF1) (HEIGHT BUF2))))
01800 (COLUMN BUF2)))
01900
02000 (DFUNC (MKATOM BUF ATOM) (MKEXPR (MKSPC (MKDOT (MKSPC BUF))) ATOM))
02100
02200 (DFUNC (MKCHAR BUF CHAR)
02300 (SETWTH (SETCOL (SETSTRING BUF
02400 (NCONC (STRING BUF)
02500 (LIST (LIST (Q CHAR) CHAR))))
02600 (ADD1 (COLUMN BUF)))
02700 (MAX (COLUMN BUF) (WIDTH BUF))))
02800
02900 (DFUNC (MKDOT BUF) (MKCHAR BUF *PT))
03000
03100 (DFUNC (MKEXPR BUF EXPR)
03200 (SETWTH (SETCOL (SETSTRING BUF
03300 (NCONC (STRING BUF)
03400 (LIST (LIST (Q EXPR) EXPR))))
03500 (PLUS (COLUMN BUF) (FLATSIZE EXPR)))
03600 (MAX (COLUMN BUF) (WIDTH BUF))))
03700
03800 (DFUNC (MKLIST BUF NUM LIST)
03900 (SETCOL
04000 (SETWTH (SETHT (SETSTRING BUF
04100 (NCONC (STRING BUF)
04200 (LIST (MCONS (Q LIST)
04300 NUM
04400 (STRING LIST)))))
04500 (COND ((LESSP NUM (COLUMN BUF))
04600 (PLUS (HEIGHT BUF) (HEIGHT LIST)))
04700 (T (SUB1 (PLUS (HEIGHT BUF) (HEIGHT LIST))))))
04800 (MAX (WIDTH BUF) (PLUS NUM (WIDTH LIST))))
04900 (PLUS NUM (COLUMN LIST))))
05000
05100 (DFUNC (MKLPR BUF) (MKCHAR BUF *LP))
05200
00100 (DFUNC (MKRPR BUF) (MKCHAR BUF *RP))
00200
00300 (DFUNC (MKSPC BUF) (MKCHAR BUF *SP))
00400
00500 (DFUNC (MKTAB BUF COL)
00600 (SETCOL (SETWTH (SETHT (SETSTRING BUF
00700 (NCONC (STRING BUF)
00800 (LIST (LIST (Q TAB) COL))))
00900 (COND ((LESSP COL (COLUMN BUF))
01000 (ADD1 (HEIGHT BUF)))
01100 (T (HEIGHT BUF))))
01200 (MAX (WIDTH BUF) COL))
01300 COL))
01400
01500 (DFUNC (PRINTIT LIST TAB)
01600 (PROG (COM)
01700 LOOP (COND ((NULL LIST) (RETURN NIL)))
01800 (SETQ COM (CAR LIST))
01900 (COND ((EQ (CAR COM) (Q TAB))
02000 (TABTO (ADD1 (PLUS TAB (CADR COM)))))
02100 ((EQ (CAR COM) (Q SPACE)) (PRINC *SP))
02200 ((EQ (CAR COM) (Q LPAR)) (PRINC *LP))
02300 ((EQ (CAR COM) (Q RPAR)) (PRINC *RP))
02400 ((EQ (CAR COM) (Q DOT)) (PRINC *PT))
02500 ((EQ (CAR COM) (Q CHAR)) (PRINC (CADR COM)))
02600 ((EQ (CAR COM) (Q EXPR)) (PRIN1 (CADR COM)))
02700 ((EQ (CAR COM) (Q LIST))
02800 (TABTO (ADD1 (PLUS TAB (CADR COM))))
02900 (PRINTIT (CDDR COM) (PLUS TAB (CADR COM)))))
03000 (SETQ LIST (CDR LIST))
03100 (GO LOOP)))
03200
03300 (DFUNC (PRINTLAP LISTING)
03400 (PROG (STAT)
03500 LOOP (COND ((NULL LISTING) (RETURN NIL)))
03600 (SETQ STAT (CAR LISTING))
03700 (SETQ LISTING (CDR LISTING))
03800 (PRINTSTAT STAT)
03900 (GO LOOP)))
04000
04100 (DFUNC (PRINTN CHAR NUM)
04200 (PROG (NO)
04300 (SETQ NO 1)
04400 LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
04500 (PRINC CHAR)
04600 (SETQ NO (ADD1 NO))
04700 (GO LOOP)))
04800
00100 (DFUNC (PRINTSTAT STAT)
00200 (PROG2 (COND ((NULL STAT) (TABTO 1) (TABTO 10))
00300 ((ATOM STAT) (TABTO 2))
00400 ((EQ (CAR STAT) (Q LAP)) (TABTO 1))
00500 (T (TABTO 10)))
00600 (PRIN1 STAT)))
00700
00800 (DFUNC (READLAP CALL)
00900 (PROG (STAT CODE)
01000 (SETQ CODE (LIST CALL))
01100 READ (SETQ STAT (ERRSET (READ)))
01200 (COND ((NULL STAT) (DATAERR EOF-READLAP)))
01300 (COND ((EQ STAT (Q $EOF$)) (DATAERR EOF-READLAP)))
01400 (SETQ STAT (CAR STAT))
01500 (SETQ CODE (CONS STAT CODE))
01600 (COND ((NULL STAT) (RETURN (REVERSE CODE))))
01700 (GO READ)))
01800
01900 (DFUNC (READLOOP ACTFUNC)
02000 (PROG (EXPR)
02100 LOOP (SETQ EXPR (ERRSET (READ)))
02200 (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
02300 (ACTFUNC (CAR EXPR))
02400 (GO LOOP)))
02500
02600 (DFUNC (SETCOL BUF NUM) (PROG2 (RPLACA BUF NUM) BUF))
02700
02800 (DFUNC (SETHT BUF NUM) (PROG2 (RPLACA (CDR BUF) NUM) BUF))
02900
03000 (DFUNC (SETSTRING BUF STRING) (PROG2 (RPLACD (CDDR BUF) STRING) BUF))
03100
03200 (DFUNC (SETWTH BUF NUM) (PROG2 (RPLACA (CDDR BUF) NUM) BUF))
03300
03400 (DFUNC (TABTO COL)
03500 (PROG NIL
03600 (COND ((GREATERP (CURCOL) COL) (LINEF 1)))
03700 (PRINTN *TB
03800 (*DIF (LSH (SUB1 COL) -3) (LSH (SUB1 (CURCOL)) -3)))
03900 (PRINTN *SP (*DIF COL (CURCOL)))))
04000
04100 (SETQ PAGEHEIGHT 64)
04200
04300 (SETQ PAGEWIDTH 105)
04400
00100 (MAPCAR (FUNCTION (LAMBDA (PAIR)
00200 (PROG2 (SET (CAR PAIR)
00300 (INTERN (ASCII (CADR PAIR))))
00400 (CAR PAIR))))
00500 (QUOTE ((*SP 40) (*TB 11)
00600 (*CR 15)
00700 (*LF 12)
00800 (*VT 13)
00900 (*FF 14)
01000 (*CO 54)
01100 (*PT 56)
01200 (*LP 50)
01300 (*RP 51)
01400 (*SL 57)
01500 (*AM 33)
01600 (*AT 100)
01700 (*RO 177)
01800 (*COLON 72)
01900 (*LB 133)
02000 (*RB 135))))
02100
02200 (MAPDEF BUFFPRIN (EXCEPTBUFF DOEXCEPT) (SPECBUFF DOSPEC))
02300
02400 (MAPDEF SPECBUFF (COMMENT BUFSPECIAL) (DE BUFDEDFDM)
02500 (DEFPROP BUFDEFS) (DF BUFDEDFDM) (DFUNC BUFDEFS)
02600 (DM BUFDEDFDM) (GETSYM BUFMAPDEF) (LABEL BUFASSIGN)
02700 (LAMBDA BUFDEFS) (MAPDEF BUFMAPDEF) (PROG BUFPROG)
02800 (SETQ BUFASSIGN) (SPECIAL BUFSPECIAL))
02900